home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / odefs.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  7KB  |  243 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;   EuLisp Module  -   Copyright (C) Codemist and University of Bath 1990   ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;                                                                           ;;
  9. ;; Name: defs                                                                ;;
  10. ;;                                                                           ;;
  11. ;; Author: Keith Playford                                                    ;;
  12. ;;                                                                           ;;
  13. ;; Date: 21 August 1990                                                      ;;
  14. ;;                                                                           ;;
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16.  
  17. ;;
  18.  
  19. ;; Change Log:
  20. ;;   Version 1.0 (21/8/90)
  21.  
  22. ;;
  23.  
  24. ;; Lisp version of defclass... */
  25.  
  26. (defmodule odefs
  27.  
  28.   (standard) ()
  29.  
  30.   ;; 'defstruct'...
  31.  
  32.   ;; Utils... 
  33.  
  34.   (defconstant *key-list-fail* nil)
  35.  
  36.   (defconstant *nothing* (gensym))
  37.  
  38.   (defun search-key-list (l k)
  39.     (cond ((null l) *key-list-fail*)
  40.       ((eqcar l k) (cadr l))
  41.       (t (search-key-list (cddr l) k))))
  42.  
  43.   (defcondition invalid-slot-options () options nil)
  44.  
  45.   (deflocal *name* nil)
  46.   (deflocal *readers* nil)
  47.   (deflocal *writers* nil)
  48.   (deflocal *accessors* nil)
  49.  
  50.   (defun canonicalise (ops)
  51.     (when (symbolp ops) (setq ops (list ops)))
  52.     (unless (consp ops) (error "slot options not a list"
  53.                    invalid-slot-options 'options ops))
  54.     (let ((name *nothing*)
  55.       (slot-class *nothing*)
  56.       (slot-initargs *nothing*)
  57.       (initform *nothing*)
  58.       (initargs nil)
  59.       (readers nil)
  60.       (writers nil)
  61.       (accessors nil))
  62.       (labels
  63.         ((inner (l)
  64.       (unless (null l) 
  65.         (let ((key (car l)) 
  66.           (val (cadr l)))
  67.           (cond ((eq key 'initarg)
  68.               (setq initargs (nconc initargs (list val))))
  69.             ((eq key 'initform)
  70.               (if (eq initform *nothing*)
  71.               (setq initform `(lambda () ,val))
  72.             (error "bad initform"
  73.                    invalid-slot-options 'options ops)))
  74.             ((eq key 'slot-class) 
  75.               (if (eq slot-class *nothing*)
  76.               (setq class val)
  77.             (error "slot-class multiply defined"
  78.                    invalid-slot-options 'options ops)))
  79.             ((eq key 'slot-initargs)
  80.               (if (eq slot-initargs *nothing)
  81.               (setq class-initargs val)
  82.             (error "slot initargs multiply defined"
  83.                    invalid-slot-options 'options ops)))
  84.             ((eq key 'reader)
  85.               (setq readers (cons (cons val name) readers)))
  86.             ((eq key 'writer)
  87.               (setq writers (cons (cons val name) writers)))
  88.             ((eq key 'accessor)
  89.               (setq accessors (cons (cons val name) accessors)))
  90.             (t (error "unknown slot option"
  91.                   invalid-slot-options 'options ops))))
  92.         (inner (cddr l)))))
  93.     (setq name (car ops))
  94.     (inner (cdr ops))
  95.     (setq *readers* (nconc readers *readers*))
  96.     (setq *writers* (nconc writers *writers*))
  97.     (setq *accessors* (nconc accessors *accessors*))
  98.     (when (eq slot-class *nothing*) 
  99.           (setq slot-class 'local-slot-description))
  100.     (when (eq slot-initargs *nothing*)
  101.           (setq slot-initargs nil))
  102.     (nconc `(list 'name          ',name 
  103.               'slot-class    ,slot-class 
  104.               'slot-initargs ,slot-initargs
  105.               'initargs      ',initargs)
  106.            (if (eq initform *nothing*) nil `('initform initform))))))
  107.  
  108.   (defun reader-defs (o) 
  109.     (mapcar 
  110.       (lambda (pair) 
  111.     `(defconstant ,(car pair) (make-reader ,*name* ',(cdr pair))))
  112.       *readers*))
  113.  
  114.   (defun writer-defs (o) 
  115.     (mapcar 
  116.       (lambda (pair) 
  117.     `(defconstant ,(car pair) (make-writer ,*name* ',(cdr pair))))
  118.       *writers*))
  119.  
  120.   (defun accessor-defs (o) 
  121.     (mapcar 
  122.       (lambda (pair) 
  123.     `(progn
  124.        (defconstant ,(car pair) (make-reader ,*name* ',(cdr pair)))
  125.        ((setter setter) ,(car pair) (make-writer ,*name* ',(cdr pair)))))
  126.       *accessors*))
  127.  
  128.   (defmacro ldefstruct (name super slot-ops . class-ops)
  129.     (setq *name* name)
  130.     `(progn
  131.        (defconstant ,name
  132.      (make-instance structure-class
  133.        'name ',name
  134.        'direct-superclasses ,(if super `(list super) '(list structure)) 
  135.        'direct-slot-descriptions
  136.          (list ,@(mapcar canonicalise slot-ops))
  137.        'metaclass-hypotheses nil))
  138.        ,@(reader-defs slot-ops)
  139.        ,@(writer-defs slot-ops)
  140.        ,@(accessor-defs slot-ops)
  141.        ',name))
  142.  
  143.   (export ldefstruct)
  144.  
  145.   (defmacro ldefclass (name supers slot-ops . class-ops)
  146.     (setq *name* name)
  147.     (let ((metaclass
  148.         (or (search-key-list class-ops 'metaclass) 'class))
  149.       (initargs 
  150.         (or (search-key-list class-ops 'metaclass-initargs) nil))
  151.       (readers)
  152.       (writers)
  153.       (accessors))
  154.       `(progn
  155.      (defconstant ,name
  156.        (make-instance ,metaclass
  157.          'name ',name
  158.          'direct-superclasses ,(if supers `(list ,@supers) '(list object))
  159.          'direct-slot-descriptions
  160.            (list ,@(mapcar canonicalise slot-ops))
  161.          'metaclass-hypotheses nil))
  162.      ,@(reader-defs slot-ops)
  163.      ,@(writer-defs slot-ops)
  164.      ,@(accessor-defs slot-ops)
  165.      ',name)))
  166.  
  167.   (export ldefclass)
  168.  
  169.   (defmacro defreader (name class slot)
  170.     `(defconstant ,name (make-reader ,class ',slot)))
  171.  
  172.   (defmacro defwriter (name class slot)
  173.     `(defconstant ,name (make-writer ,class ',slot)))
  174.  
  175.   (defmacro defaccessor (name class slot)
  176.     `(progn
  177.        (defconstant ,name (make-reader ,class ',slot))
  178.        ((setter setter) ,name (make-writer ,class ',slot))))
  179.  
  180.   (export defreader defwriter defaccessor)
  181.  
  182.   (defun sll-signature (ll)
  183.     (cond ((not (consp ll)) nil)
  184.       ((consp (car ll)) (cons (cadar ll) (sll-signature (cdr ll))))
  185.       (t (cons 'object (sll-signature (cdr ll))))))
  186.  
  187.   (defun sll-formals (ll)
  188.     (cond ((not (consp ll)) nil)
  189.       ((consp (car ll)) (cons (caar ll) (sll-formals (cdr ll))))
  190.       (t (cons (car ll) (sll-formals (cdr ll))))))
  191.  
  192.   (defun gf-class (ops)
  193.     (let ((val (search-key-list ops 'class)))
  194.       (if (eq val *key-list-fail*) 'generic-function val)))
  195.  
  196.   (defun gf-method-class (ops)
  197.     (let ((val (search-key-list ops 'method-class)))
  198.       (if (eq val *key-list-fail*) 'method val)))
  199.     
  200.   (defun gf-methods (ops mc)
  201.     (let ((val (search-key-list ops 'methods)))
  202.       (if (eq val *key-list-fail*) nil
  203.     `(list
  204.         ,@(mapcar
  205.             (lambda (form)
  206.               `(make-instance ,mc
  207.              'signature (list ,@(sll-signature (car form)))
  208.              'function
  209.              (lambda (***method-args-handle***
  210.                   ***method-status-handle***
  211.                   ,@(sll-formals (car form)))
  212.                ,@(cdr form)))) 
  213.         val)))))
  214.  
  215.   (defmacro ldefgeneric (name ll . ops)
  216.     `(defconstant ,name
  217.        (make-instance ,(gf-class ops)
  218.       'name ',name
  219.           'lambda-list ',ll
  220.       'method-class ,(gf-method-class ops)
  221.       'methods ,(gf-methods ops (gf-method-class ops)))))
  222.  
  223.   (defmacro ldefmethod (name sll . body)
  224.     `(progn
  225.        (add-method 
  226.      ,name
  227.      (make-instance (generic-function-method-class ,name)
  228.             'signature (list ,@(sll-signature sll))
  229.             'function
  230.               (lambda (***method-args-handle***
  231.                    ***method-status-handle***
  232.                    ,@(sll-formals sll)) 
  233.                 ,@body)))))
  234.  
  235.   (defclass lockable-gf (generic-function)
  236.     ((lock initarg lock
  237.        initform nil
  238.        accessor lockable-gf-lock))
  239.     metaclass generic-class)
  240.     
  241. )
  242.  
  243.